#!/usr/bin/perl -w
package XNAT::Connection;
use strict;

my ($prog,$progdir);
BEGIN {
    $0 =~ m{(.*)/(.*?)$};
    ($progdir,$prog) = ($1,$2);
    $progdir = '.' unless $progdir;
    #print "$progdir\n";
    push @INC, "$progdir/lib", "$progdir";
    #print join(':',@INC),"\n";
}

use Carp qw(croak carp cluck confess);
use Cwd qw( abs_path getcwd );
use Data::Dumper;
use HTTP::Request;
use LWP::UserAgent;
use Time::HiRes qw(usleep ualarm gettimeofday tv_interval);
use XML::Simple;
use XNAT::Config;

$|=1;

my $script_t0 = [gettimeofday];

=head1 XNAT::Connection

XNAT::Connection - an object for connecting to XNAT

=head2 EXAMPLE USAGE

 my $xconn = XNAT::Connection->new(host=>"exanple");

 or

 my $xconn = XNAT::Connection->new(url=>"http://www.xnat.example.com:9912/bar");

 # get a session zip file and save to SOME_SESSION_ID.zip in the current directory.

 $xconn->getSession(id=>'SOME_SESSION_ID',output_dir=>'./') || die;

=head2 METHODS

=over 4

=cut

=item XNAT::Connection->new()

Returns a new connection object. Can be called like so:

C<< my $xconn = XNAT::Connection->new({%params}); >>

If one or more of the parameters are missing, it looks for a config file with the information. Minimum required parameters (either specified when called or read from the config file) are host or url, login, pass.

=over

=item C<< url >>

The XNAT host URL in "http://www.xnat.example.com:9912/bar" format.

=item C<< host >>

If the config file contains a section for "example" (See XNAT::Config) you can specify "example" as the host, and the XNAT URL will be read from that section of the config file.

=item C<< login >>

The XNAT login to use.

=item C<< pass >>

The password to use to log into XNAT.

=item C<< config >>

The file name (full or relative path) of the XNAT::Config complient config file to use.

=back

See XNAT::Config for more information on the config file.

=cut

sub new {
  if($main::verbose > 4) { my ($pack,$file,$line,$sub) = caller; cluck "DEBUG: ${pack}::${sub}() called "; }
    my $class = shift;
    my $self = {@_};
    bless $self,$class;
    # Create a new config for this connection.
    $self->{config} = XNAT::Config->new($self->{host});
    # Create a new user agent for this connection. Each connection object has its own
    # UserAgent object, so if you don't want to have multiple sessions, simply use the
    # same Connection object.
    $self->{ua} = LWP::UserAgent->new(agent => 'XNAT::Connection Browser/0.01alpha',
				      cookie_jar => {});
    if($self->host) {
      my $errors = "";
      $errors .= "ERROR: XNAT::Connection->new() called but I was not able to determine the XNAT host.\n"
	unless $self->config->host;
      $errors .= "ERROR: XNAT::Connection->new() called but I was not able to determine the XNAT url.\n"
	unless $self->config->url;
      $errors .= "ERROR: XNAT::Connection->new() called but I was not able to determine the XNAT login.\n"
	unless $self->config->login;
      $errors .= "ERROR: XNAT::Connection->new() called but I was not able to determine the XNAT password.\n"
	unless $self->config->pass;
      if( $errors ) {
	confess $errors,"ERROR: XNAT::Connection->new() called but could not get enough information to do anything.\n";
      }
    }
    # Start a session.
    $self->_createXNATHTTPSession();

    # Remember to return the $self at the end!
    $self;
}

=item $xconn->loadConfig($host)

Load the config file settings for the host=$host section of the ~/.xnat.d/xnat.conf file. Of no $host is supplied, we use the value of $xconn->host. If $host is supplied, we also call $xconn->host($host).

=cut

sub loadConfig {
  if($main::verbose > 4) { my ($pack,$file,$line,$sub) = caller; cluck "DEBUG: ${pack}::${sub}() called "; }
  my $self = shift;
  my $host = shift;
  if($host) {
    $self->config->host($host);
  } else {
    if($self->host) {
      $host = $self->host;
    } else {
      confess "ERROR: \$xconn->loadConfig called, but I don't know which host.";
    }
  }
}

=item $xconn->host()

Same as $xconn->config->host().

=cut

sub host { my $self=shift;$self->config->host(@_); }

=item $xconn->url()

Same as $xconn->config->url().

=cut

sub url { my $self=shift;$self->config->url(@_); }

=item $xconn->login()

Same as $xconn->config->login().

=cut

sub login { my $self=shift;$self->config->login(@_); }

=item $xconn->pass()

Same as $xconn->config->pass().

=cut

sub pass { my $self=shift;$self->config->pass(@_); }

=item $xconn->config()

Get the configuration object for this XNAT::Connection. This is read-only.

=cut

sub config { $_[0]->{config} }

=item $xconn->getSession({%params})

Get an entire session from XNAT, including all files. Usually called like so:

 $xconn->getSession(id=>'SESSION_ID');

If you have access to more than one session with that id (e.g., you have access to two projects that used that id on separate sessions), you will have issues with this. If this happens, you'll have to get someone to modify this library to deal with that, since it wont for now.

The default behavior of $xconn->getSession(id=>'SESSION_ID') is to download the zipped session files to a file called session_id.zip in the current working directory, unzip the files in the session_id.zip file into a directory called session_id in the current working directory, uncompress all the files, and remove the session_id.zip file.

The parameter "id" is required. A list of parameters follows:

=over

=item C<< id >>

B<< Required >>. This is the session_id of the session to retreive.

=item C<< failure_not_fatal >>

If set to non-zero, don't exit the script with non-zero (failure) status if we fail to get the session, just return from the call with a false. The default is to die a horrible death.

=item C<< output_dir >>

The directory to output the retreived .zip file.

=item C<< zip_filename >>

The name of the zip file. Default is session_id.zip.

=item C<< dont_unzip >>

If set to non-zero, the file will not be unzipped. The default behavior is to unzip the files and not to keep the zip file around.

=item C<< dont_uncompress_files >>

If set to non-zero, after the session_id.zip file is unzipped, the files inside that archive will in turn B<< not >> be decompressed but will be left as they are. The default behavior is to uncompress all files in the zip archive.

=item C<< keep_zip >>

If set to non-zero, the zip file will be kept around. Not useful if C<< dont_unzip >> is specified. The default behavior is to unzip the files and not to keep the zip file around.

=item C<< session_dir >>

Specify the name of the directory into which 

=item C<< quality >>

The quality of scans to get. Should be "usable", "questionable",  or "unusable"

=item C<< scans >>

The scan numbers to get (e.g., "1", or "7,12"), scan type to get (e.g., "BOLD" or "MPRAGE,DTI") or a mixture of both (e.g., "LOCALIZER,DTI,6,19". Can be one or more, separated by commas.

=item C<< if_zip_exists >>

What to do if the zip file already exists. Options are "ask", "use", "overwite", "backup", and "fail". "use" will cause the script to use the file that's there rather than download a new one, "overwrite" will overwrite the file with the new one, "backup" will move the previous file to backup and create a new one, "fail" will cause the script to exit non-zero, and "ask" will ask the user. Default is "use".

=item C<< if_dir_exists >>

What to do if the session directory already exists. Options are "ask", "use", "overwite", "backup", and "fail". "use" will cause the script to use the contents of the existing directory rather than download data, "overwrite" will overwrite any contents with new data, "backup" will move the previous files to backup and create new ones, "fail" will cause the script to exit non-zero, and "ask" will ask the user.

=back

=cut

sub getSession {
  if($main::verbose > 4) { my ($pack,$file,$line,$sub) = caller; cluck "DEBUG: ${pack}::${sub}() called "; }
  my ($self,$params) = @_;
  # Do some sanity checking
  $self->_check_for_id($params);
  # Set defaults.
  $params->{if_zip_exists} = "overwrite" unless defined $params->{if_zip_exists};
  $params->{output_dir} = "./" unless defined $params->{output_dir};

  # Where are we?
  my $cwd = getcwd;
  # Start the XNAT HTTP Session if it was not already started.
  $self->_createXNATHTTPSession() unless $self->{_session_started};
  # If we're very verbose, say what we're doing.
  print "Getting xnat:mrSessionData.ID='$params->{id}'.\n" if $main::verbose > 2;
  # Make all paths absolute
  if($params->{output_dir} ) {
    $params->{output_dir} = abs_path($params->{output_dir});
  } else {
    $params->{output_dir} = getcwd;
  }
  if($params->{zip_filename}) {
    # Remap to absolute filename only if not already absolute.
    $params->{zip_filename} = abs_path($params->{zip_filename}) unless $params->{zip_filename} =~ m{^/};
  } else {
    $params->{zip_filename} = abs_path($params->{output_dir}."/".$params->{id}.".zip");
  }
  if($params->{session_dir}) {
    # Remap to absolute filename only if not already absolute.
    $params->{session_dir} = abs_path($params->{session_dir}) unless $params->{session_dir} =~ m{^/};
  } else {
    $params->{session_dir} = abs_path($params->{output_dir}."/".$params->{id});
  }
  # Now go get the file.
  my $url = $self->{config}->url()."/app/template/ArcGet.vm";
  $url .= "/id/$params->{id}" if $params->{id};
  $url .= "/raw/$params->{scans}" if $params->{scans};
  if($params->{quality}) {
    $url .= "/quality/$params->{quality}";
  } else {
    $url .= "/quality/ALL";
  }
  my $output_zipfile = $params->{id}.".zip";
  if ($params->{zip_filename}) {
    $output_zipfile = $params->{zip_filename};
    $output_zipfile = $output_zipfile.".zip" unless $output_zipfile =~ /\.zip$/;
  }
  # If we're supposed to put the zipfile somewhere special, make it so.
  if($params->{output_dir} && ! -e $params->{output_dir}) {
    $self->_critical_mkdir($params->{output_dir});
  }
  # if the zipfile eaxists, what do we do?
  my $download_new = 1;
  if(-e $params->{if_zip_exists}) {
    if("ask" == $params->{if_zip_exists}) {
      confess "ERROR: if_zip_exists=>\"ask\" is not implemented yet.\n";
    } elsif("use" == $params->{if_zip_exists} || ! $params->{if_zip_exists} ) {
      warn "WARNING: '$params->{if_zip_exists}' exists, will use it instead of downloading a new one.\n";
      $download_new = 0;
    } elsif("backup" == $params->{if_zip_exists} ) {
      # Get the modified time / date of the file.
      my($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst)
	= localtime( (stat($params->{zip_filename}))[9] );
      my $stamp = sprintf('%04d.%02d.%02d-%02d.%02d.%02d',($year + 1900),$mday,($mon+1),$hour,$min,$sec);
      my $root = $params->{zip_filename}; $root =~ s{.zip$}{};
      my $newfile = "$root.$stamp.zip";
      warn "WARNING: '$params->{zip_filename}' exists, will backup to '$newfile'.\n";
      $self->_critical_rename($params->{zip_filename},$newfile);
      $download_new = 1;
    } elsif("overwrite" == $params->{if_zip_exists} ) {
      warn "WARNING: '$params->{if_zip_exists}' exists, will overwrite.\n";
      $download_new = 1;
    } elsif("fail" == $params->{if_zip_exists} ) {
      confess "WARNING: '$params->{if_zip_exists}' exists, and if_zip_exists=\"fail\", cannot continue.\n";
      $download_new = 0;
    }
  }
  if ($download_new) {
    # Now create the zipfile
    open(SESSION_OUT,"> $params->{zip_filename}")|| confess "ERROR: Unable to open '$params->{zip_filename}' for writing!\nREASON:$!\n";

    # And download the zipfile
    my $t0  = [gettimeofday];
    my $download_start;
    my $size = 0;
    my $count = 0;
    my $req = HTTP::Request->new(GET => $url);
    $req->authorization_basic($self->{config}->login(),$self->{config}->password());
    my $res = $self->{ua}->request($req,
				   sub {
				     my ($chunk,$response,$protocol) = @_;
				     $download_start = [gettimeofday] unless $download_start;
				     # Failure to write the file is always fatal, but try to clean up if possible.
				     if (! print SESSION_OUT $chunk) {
				       close SESSION_OUT || warn "WARNING: Unable to close '$params->{zip_filename}' filehandle: $!.\n";
				       unlink $params->{zip_filename} || warn "WARNING: Unable to remove bad file '$params->{zip_filename}': $!.\n";
				       confess "ERROR: Unable to write to $params->{zip_filename} after $size bytes!\nREASON:$!\n";
				     }
				     # Increase after write attempt, not before.
				     $size += length $chunk;
				     # Provide some feedback if so desired.
				     if ($main::verbose > 0) {
				       $count++;
				       if ($count % 1_024 == 0) {
					 print ".";
				       }
				       if ($count % 51_200 == 0) {
					 my $rate = $size / tv_interval($download_start);
					 print " ".prettySize($size)." ".prettyRate($rate)."\n";
				       }
				     }
				   }
				  );
    # Now give a summary of what just happened to those who want it.
    my $t1 = tv_interval($t0);
    print "\nWrote '$params->{zip_filename}':".prettySize($size)." ".prettyRate($size / $t1 )." (effective)\n" if($main::verbose);
    if ($res->is_success) {
      print "OK - $url - $t1 seconds.\n" if $main::verbose > 1;
    } else {
      # Doh! Something aint right. Die if need be, but provide some useful if ugly feedback.
      print $res->status_line, "- $url - $t1 seconds.\n" if $main::verbose > 1;
      print $res->content, "\n" if $main::verbose > 2;
      if (! $params->{failure_not_fatal}) {
	confess ("ERROR: Failed to get session '$params->{id}'! Cannot continue!\n",
		 "Server said: ",$res->status_line,"\n",
		 "Server Jobberish useful when emailing for help:\n",
		 $res->content,
		 "NOTICE: Please include the above then asking for help.\n",
		);
      } else {
	warn ("WARNING: Failed to get session '$params->{id}'! Will try to continiue, since I was told to.\n",
	      "Server said: ",$res->status_line,"\n",
	      "Server Jobberish useful when emailing for help:\n",
	      $res->content,
	      "NOTICE: Please include the above then asking for help.\n",
	     );
	return 0;
      }
    }
  }
  # If we're not supposed to unzip, we can ignore the rest.
  if($params->{dont_unzip}) {
    print "Not unzipping '$params->{zip_filename}'.\n" if $main::verbose > 0;
    return 1;
  }
  # Make the session directory first. Even if we don't junk the path information, we
  # should work inside the "new" directory so that we know what zip created easily.
  $self->_critical_chdir($params->{output_dir});
  # if the zipfile eaxists, what do we do?
  my $create_dir = 1;
  if(-e $params->{if_zip_exists}) {
    if("ask" == $params->{if_zip_exists}) {
      confess "ERROR: if_zip_exists=>\"ask\" is not implemented yet.\n";
    } elsif("use" == $params->{if_zip_exists} || ! $params->{if_zip_exists} ) {
      warn "WARNING: '$params->{if_zip_exists}' exists, will use it instead of downloading a new one.\n";
      $create_dir = 0;
    } elsif("backup" == $params->{if_zip_exists} ) {
      # Get the modified time / date of the file.
      my($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst)
	= localtime( (stat($params->{zip_filename}))[9] );
      my $stamp = sprintf('%04d.%02d.%02d-%02d.%02d.%02d',($year + 1900),$mday,($mon+1),$hour,$min,$sec);
      my $root = $params->{zip_filename}; $root =~ s{.zip$}{};
      my $newfile = "$root.$stamp.zip";
      warn "WARNING: '$params->{zip_filename}' exists, will backup to '$newfile'.\n";
      $self->_critical_rename($params->{zip_filename},$newfile);
      $create_dir = 1;
    } elsif("overwrite" == $params->{if_zip_exists} ) {
      warn "WARNING: '$params->{if_zip_exists}' exists, will overwrite.\n";
      $create_dir = 1;
    } elsif("fail" == $params->{if_zip_exists} ) {
      confess "WARNING: '$params->{if_zip_exists}' exists, and if_zip_exists=\"fail\", cannot continue.\n";
      $create_dir = 0;
    }
  }

  if($params->{dont_junk_paths}) {
    confess "Oops, I have not implemented the 'dont_junk_paths' parameter yet!\n";
  } else {
    # We're junking the paths, so we should create the appropriate directory first
    $self->_critical_mkdir($params->{session_dir});
    # Then cd into it so all the files appear in this new directory
    $self->_critical_chdir($params->{session_dir});
    # Now unzip the files.
    print "Unzipping '$params->{zip_filename}'\n" if $main::verbose > 0;
    $self->_critical_cmd('unzip','-q','-j','-o',$params->{zip_filename});
    # Delete the zip file if we're supposed to.
    $self->_critical_unlink($params->{zip_filename}) unless $params->{keep_zip};
    # Now we need to create the directory structurein a manner that is useful to the users.
    opendir(DIR,$params->{session_dir}) || confess "ERROR: Unable to open directory '$params->{session_dir}' for reading!\nREASON: $!\n";
    my @files = readdir(DIR);
    closedir(DIR);
    $self->_critical_mkdir('RAW');
    $self->_critical_mkdir('MISC');
    print "Uncompressing and renaming (if needed) session files.\n" if $main::verbose > 0;
    foreach my $file (@files) {
      next unless -f $file;
      if($file =~ m{\.dcm$}) {
	$self->_critical_rename($file,"RAW/$file");
	$file = "RAW/$file";
      } elsif($file =~ m{\.dcm.gz$}) {
        $self->_critical_rename($file,"RAW/$file");
        $file = "RAW/$file";
        $self->_critical_cmd('gunzip','-f',$file);
	$file =~ s{.gz$}{};
      } elsif($file =~ m{\.nii.gz$}) {
        $self->_critical_rename($file,"RAW/$file");
        $file = "RAW/$file";
      } elsif($file =~ m{\.nii$}) {
        $self->_critical_rename($file,"RAW/$file");
        $file = "RAW/$file";
        $self->_critical_cmd('gzip','-9',$file);
	$file .= ".gz";;
      } else {
        $self->_critical_rename($file,"MISC/$file");
        $file = "MISC/$file";
      }
    }
  }
  $self->_critical_chdir($cwd);
}

# Try to unlink (delete) or die hirribly.
sub _critical_unlink {
  if($main::verbose > 4) { my ($pack,$file,$line,$sub) = caller; cluck "DEBUG: ${pack}::${sub}() called "; }
  my $self = shift if ref $_[0];
  confess "Wrong number of parameters to function. " unless @_ == 1;
  my $what = shift;
  if(! unlink($what) ) {
    confess "ERROR: Unable to delete '$what' (cwd='".getcwd."'!\nREASON: $!\n";
  }
}

# Try to unlink (delete) or die hirribly.
sub _critical_rename {
  if($main::verbose > 4) { my ($pack,$file,$line,$sub) = caller; cluck "DEBUG: ${pack}::${sub}() called "; }
  my $self = shift if ref $_[0];
  confess "Wrong number of parameters to function. " unless @_ == 2;
  my ($from,$to) = @_;
  if(! rename($from,$to) ) {
    confess "ERROR: Unable to rename '$from' to '$to' (cwd='".getcwd."'!\nREASON: $!\n";
  }
}

# Try to run a system command or die horribly.
sub _critical_cmd {
  if($main::verbose > 4) { my ($pack,$file,$line,$sub) = caller; cluck "DEBUG: ${pack}::${sub}() called "; }
  my $self = shift if ref $_[0];
  confess "Wrong number of parameters to function. " unless @_;
  my @cmd = @_;
  my $rv = system(@cmd);
  if($rv) {
    confess "ERROR: Unable to run @cmd!\nREASON:$!\n";
  }
}
# Try to change working directory or die horribly.
sub _critical_chdir {
  if($main::verbose > 4) { my ($pack,$file,$line,$sub) = caller; cluck "DEBUG: ${pack}::${sub}() called "; }
  my $self = shift if ref $_[0];
  my $dir = shift || confess "Wrong number of parameters to function. ";
  chdir($dir) || confess "ERROR: Unable to change directory to '$dir'!\nREASON: $!\n";
  print "Changed directory to '".getcwd."'.\n" if $main::verbose > 2;
}
# Try to make a directory (if not already there) or die horribly.
sub _critical_mkdir {
  if($main::verbose > 4) { my ($pack,$file,$line,$sub) = caller; cluck "DEBUG: ${pack}::${sub}() called "; }
  my $self = shift if ref $_[0];
  my $dir = shift || confess "Wrong number of parameters to function. ";
  if(! -e $dir) {
    mkdir($dir) || confess "ERROR: Unable to create directory '$dir'!\nREASON: $!\n";
  } else {
    confess "ERROR: Directory '$dir' is either not executable or not writable. Cannot continue.\n" unless -r $dir && -w $dir;
  }
}

=item $xconn->isXNAT()

Checks if the current connection object is configured to connect to an XNAT installation. Returns true if it is, false otherwise.

=cut

sub isXNAT {
  if($main::verbose > 4) { my ($pack,$file,$line,$sub) = caller; cluck "DEBUG: ${pack}::${sub}() called "; }
  my $self = shift;
  print "Checking is ".$self->{config}->url()." is pointing to XNAT.\n" if $main::verbose > 2;
  my $url = $self->{config}->url()."/axis/XMLSearch.jws?";
  my $t0 = [gettimeofday];
  my $res = $self->{ua}->get($url, login => $self->{config}->login(), password => $self->{config}->pass());
  my $t1 = tv_interval($t0);

  if ($res->is_success) {
    print "OK - $url - $t1 seconds.\n" if $main::verbose > 1;
    1;
  } else {
    print $res->status_line, "- $url - $t1 seconds.\n" if $main::verbose > 1;
    print $res->content, "\n" if $main::verbose > 2;
    0;
  }
}

sub _createXNATHTTPSession {
  if($main::verbose > 4) { my ($pack,$file,$line,$sub) = caller; cluck "DEBUG: ${pack}::${sub}() called "; }
    my $self = shift;
    if(! $self->{_session_started}) {
	print "Creating an XNAT session ($self->{config}->{url}).\n" if $main::verbose > 2;
	my $url = $self->{config}->{url}."/axis/CreateServiceSession.jws";
	my $t0 = [gettimeofday];
	my $req = HTTP::Request->new(POST => $url);
	$req->authorization_basic($self->{config}->login(),$self->{config}->pass());
	$req->header(SOAPAction => "\"\"");
	$req->content_type("text/xml; charset=utf-8");
	$req->content('<?xml version="1.0" encoding="UTF-8"?>
<soapenv:Envelope xmlns:soapenv="http://schemas.xmlsoap.org/soap/envelope/" xmlns:xsd="http://www.w3.org/2001/XMLSchema" xmlns:xsi="http://www.w3.org/2001/XMLSchema-instance">
<soapenv:Body><execute soapenv:encodingStyle="http://schemas.xmlsoap.org/soap/encoding/"/>
</soapenv:Body>
</soapenv:Envelope>');
	print "Sending POST request to $url...\n" if $main::verbose > 3;
	my $res = $self->{ua}->request($req);
	print "Checking POST request to $url...\n" if $main::verbose > 3;
	my $t1 = tv_interval($t0);
	if ($res->is_success) {
	    print "OK - $url - $t1 seconds.\n" if $main::verbose > 1;
	} else {
	    print $res->status_line, "- $url - $t1 seconds.\n" if $main::verbose > 1;
	    print $res->content, "\n" if $main::verbose > 2;
	    warn "ERROR: Unable to create XNAT session while connecting to $self->{config}->{url}!\n".
		"REASON: '",$res->status_line,"'\n";
	    exit -1;
	}
	$self->{_session_started} = 1;
      }
}

=item $cenn->getAllSessionIDs()

Returns an array with all session IDs in XNAT.

=cut

sub getAllSessionIDs {
  if($main::verbose > 4) { my ($pack,$file,$line,$sub) = caller; cluck "DEBUG: ${pack}::${sub}() called "; }
  my $self = shift;
  print "Searching XNAT for All Sessions.\n" if $main::verbose > 2;
  my $url = $self->{config}->url()."/axis/GetIdentifiers.jws";
  my $t0 = [gettimeofday];
  my $req = HTTP::Request->new(POST => $url);
  $req->authorization_basic($self->{config}->login(),$self->{config}->pass());
  $req->header(SOAPAction => "\"\"");
  $req->content_type("text/xml; charset=utf-8");
  $req->content('<?xml version="1.0" encoding="UTF-8"?>
<soapenv:Envelope xmlns:soapenv="http://schemas.xmlsoap.org/soap/envelope/" xmlns:xsd="http://www.w3.org/2001/XMLSchema" xmlns:xsi="http://www.w3.org/2001/XMLSchema-instance">
<soapenv:Body>
<search soapenv:encodingStyle="http://schemas.xmlsoap.org/soap/encoding/">
<arg0 xsi:type="soapenc:string" xmlns:soapenc="http://schemas.xmlsoap.org/soap/encoding/">0A2A9AE6E8DEFCA421FA6308097BC957</arg0>
<arg1 xsi:type="soapenc:string" xmlns:soapenc="http://schemas.xmlsoap.org/soap/encoding/">xnat:MRSession.ID</arg1>
<arg2 xsi:type="soapenc:string" xmlns:soapenc="http://schemas.xmlsoap.org/soap/encoding/">LIKE</arg2>
<arg3 xsi:type="soapenc:string" xmlns:soapenc="http://schemas.xmlsoap.org/soap/encoding/">%</arg3>
<arg4 xsi:type="soapenc:string" xmlns:soapenc="http://schemas.xmlsoap.org/soap/encoding/">xnat:MRSession</arg4>
</search>
</soapenv:Body>
</soapenv:Envelope>');
  my $res = $self->{ua}->request($req);
  my $t1 = tv_interval($t0);

  if ($res->is_success) {
    print "OK - $url - $t1 seconds.\n" if $main::verbose > 1;
    my $content = $res->content;
    print $content, "\n" if $main::verbose > 2;
    #print $content,"\n";
    my $soap = XMLin($content);
    print Dumper($soap) if $main::verbose > 2;
    my @results = ();
    if($soap->{'soapenv:Body'}->{'multiRef'}->{'multiRef'}) {
      foreach my $hash_ref (@{$soap->{'soapenv:Body'}->{'multiRef'}->{'multiRef'}}) {
	push @results,$hash_ref->{content};
      }
    }
    print Dumper(@results) if $main::verbose > 3;
    @results;
  } else {
    print $res->status_line, "- $url - $t1 seconds.\n" if $main::verbose > 1;
    print $res->content, "\n" if $main::verbose > 2;
    undef;
  }
}

=item $cenn->getBriefSessionInfo()

Get the brief session information return by XNAT. Returns a text string with human readible information. Not very useful for parsing, but provides good information to the user.

=cut

sub getBriefSessionInfo {
  if($main::verbose > 4) { my ($pack,$file,$line,$sub) = caller; cluck "DEBUG: ${pack}::${sub}() called "; }
  my ($self,$params) = @_;
  # Do some sanity checking
  $self->_check_for_id($params);
  my $session_id = $params->{id};
  print "Searching XNAT for xnat:mrSessionData.ID='$session_id'.\n" if $main::verbose > 2;
  my $url = $self->{config}->url()."/axis/VelocitySearch.jws";
  my $t0 = [gettimeofday];
  my $req = HTTP::Request->new(POST => $url);
  $req->authorization_basic($self->{config}->login(),$self->{config}->pass());
  $req->header(SOAPAction => "\"\"");
  $req->content_type("text/xml; charset=utf-8");
  $req->content('<?xml version="1.0" encoding="UTF-8"?>
<soapenv:Envelope xmlns:soapenv="http://schemas.xmlsoap.org/soap/envelope/" xmlns:xsd="http://www.w3.org/2001/XMLSchema" xmlns:xsi="http://www.w3.org/2001/XMLSchema-instance">
<soapenv:Body>
<search soapenv:encodingStyle="http://schemas.xmlsoap.org/soap/encoding/">
<arg0></arg0>
<arg1 xsi:type="soapenc:string" xmlns:soapenc="http://schemas.xmlsoap.org/soap/encoding/">xnat:mrSessionData.ID</arg1>
<arg2 xsi:type="soapenc:string" xmlns:soapenc="http://schemas.xmlsoap.org/soap/encoding/">=</arg2>
<arg3 xsi:type="soapenc:string" xmlns:soapenc="http://schemas.xmlsoap.org/soap/encoding/">'.$session_id.'</arg3>
<arg4 xsi:type="soapenc:string" xmlns:soapenc="http://schemas.xmlsoap.org/soap/encoding/">xnat:mrSessionData</arg4>
<arg5 xsi:type="soapenc:string" xmlns:soapenc="http://schemas.xmlsoap.org/soap/encoding/">xnat_mrSessionData_brief.vm</arg5>
</search>
</soapenv:Body>
</soapenv:Envelope>');
  my $res = $self->{ua}->request($req);
  my $t1 = tv_interval($t0);

  if ($res->is_success) {
    print "OK - $url - $t1 seconds.\n" if $main::verbose > 1;
    my $content = $res->content;
    print $content, "\n" if $main::verbose > 2;
    $content;
  } else {
    print $res->status_line, "- $url - $t1 seconds.\n" if $main::verbose > 1;
    print $res->content, "\n" if $main::verbose > 2;
    undef;
  }
}

=item $xconn->getSessionInfo()

Return the XML string containing the "long" of "full" session XML contained in XNAT. Useful for parsing fhings like SequenceDescription, etc.

=cut

sub getSessionInfo {
  if($main::verbose > 4) { my ($pack,$file,$line,$sub) = caller; cluck "DEBUG: ${pack}::${sub}() called "; }
  my ($self,$params) = @_;
  # Do some sanity checking
  $self->_check_for_id($params);
  my $session_id = $params->{id};
  print "Searching XNAT for xnat:mrSessionData.ID='$session_id'.\n" if $main::verbose > 2;
  my $url = $self->{config}->url()."/axis/VelocitySearch.jws";
  my $t0 = [gettimeofday];
  my $req = HTTP::Request->new(POST => $url);
  $req->authorization_basic($self->{config}->login(),$self->{config}->pass());
  $req->header(SOAPAction => "\"\"");
  $req->content_type("text/xml; charset=utf-8");
  $req->content('<?xml version="1.0" encoding="UTF-8"?>
<soapenv:Envelope xmlns:soapenv="http://schemas.xmlsoap.org/soap/envelope/" xmlns:xsd="http://www.w3.org/2001/XMLSchema" xmlns:xsi="http://www.w3.org/2001/XMLSchema-instance">
<soapenv:Body>
<search soapenv:encodingStyle="http://schemas.xmlsoap.org/soap/encoding/">
<arg0></arg0>
<arg1 xsi:type="soapenc:string" xmlns:soapenc="http://schemas.xmlsoap.org/soap/encoding/">xnat:mrSessionData.ID</arg1>
<arg2 xsi:type="soapenc:string" xmlns:soapenc="http://schemas.xmlsoap.org/soap/encoding/">=</arg2>
<arg3 xsi:type="soapenc:string" xmlns:soapenc="http://schemas.xmlsoap.org/soap/encoding/">'.$session_id.'</arg3>
<arg4 xsi:type="soapenc:string" xmlns:soapenc="http://schemas.xmlsoap.org/soap/encoding/">xnat:mrSessionData</arg4>
<arg5 xsi:type="soapenc:string" xmlns:soapenc="http://schemas.xmlsoap.org/soap/encoding/">xnat_mrSessionData.vm</arg5>
</search>
</soapenv:Body>
</soapenv:Envelope>');
  my $res = $self->{ua}->request($req);
  my $t1 = tv_interval($t0);

  if ($res->is_success) {
    print "OK - $url - $t1 seconds.\n" if $main::verbose > 1;
    my $content = $res->content;
    print $content,"\n" if $main::verbose > 3;
    #print $content,"\n";
    my $soap = XMLin($content);
    print Dumper($soap) if $main::verbose > 3;
    my $results = 'NONE';
    if($soap->{'soapenv:Body'} &&
       $soap->{'soapenv:Body'}->{'searchResponse'} &&
       $soap->{'soapenv:Body'}->{'searchResponse'}->{'searchReturn'} &&
       $soap->{'soapenv:Body'}->{'searchResponse'}->{'searchReturn'}->{'content'}) {
      $results = $soap->{'soapenv:Body'}->{'searchResponse'}->{'searchReturn'}->{'content'};
      if($results =~ m/<[^<]*xml/i) {
	$results = XMLin($soap->{'soapenv:Body'}->{'searchResponse'}->{'searchReturn'}->{'content'});
      }
    }
    if($results eq 'No Matches Found.' || $results eq 'NONE') {
      warn "WARNING: No such session id='$params->{id}' found at $url.\n";
      return undef;
    }
    print Dumper($results) if $main::verbose > 2;
    print XMLout($results) if $main::verbose > 3;
    $results;
  } else {
    print $res->status_line, "- $url - $t1 seconds.\n" if $main::verbose > 1;
    print $res->content, "\n" if $main::verbose > 2;
    undef;
  }
}

=item $xconn->getFCScanList(id=>$session_id)

Gets a list of latfast compatible scans for a given scan session.

=cut

sub getFCScanList {
  if($main::verbose > 4) { my ($pack,$file,$line,$sub) = caller; cluck "DEBUG: ${pack}::${sub}() called "; }
  my ($self,$params) = @_;
  # Do some sanity checking
  $self->_check_for_id($params);
  my $session_id = $params->{id};
  my $xml = $self->getSessionInfo($params);
  if($xml) {
    if(! $xml->{'xnat:scans'}) {
      warn "WARNING: No scans found for session_id='$session_id'.\n" if $main::verbose > 0;
      return undef;
    }
    my $session_label = $xml->{'label'};
    my ($scans,$mpr,@bolds) = ({},'',());
    foreach my $scan (@{$xml->{'xnat:scans'}->{'xnat:scan'}}) {
      if($scan->{'xnat:series_description'} eq 'T1_MEMPRAGE RMS' && $scan->{'xnat:quality'} eq 'usable') {
	$scans->{$scan->{'ID'}} = $scan;
	warn("WARNING: Found more than one 'usable' xnat:series_description='T1_MEMPRAGE RMS' for  session '$session_label', using last one found.\n") if $mpr;
	$mpr = $scan;
      }
      if($scan->{'xnat:series_description'} eq 'fMRI_resting_state' && $scan->{'xnat:quality'} eq 'usable') {
	$scans->{$scan->{'ID'}} = $scan;
	push @bolds,$scan;
      }
    }
    print "FC Scans for session '$session_label':\n" if $main::verbose > 0;
    if(!$mpr && !@bolds) {
      warn "WARNING: Found no 'usable' FC Scan data for session '$session_label'.\n";
      return undef;
    }
    if(!$mpr) {
      warn "WARNING: Found no 'usable' xnat:series_description='T1_MEMPRAGE RMS' for session '$session_label'.\n";
      return undef;
    }
    if(!@bolds) {
      warn "WARNING: Found no 'usable' xnat:series_description='fMRI_resting_state' for session '$session_label'.\n";
      return undef;
    }
    if($main::verbose) {
      printf " - MPRAGE: Scan # %2d, Type = %-10s, Quality = %-10s, TR = %6.2f, SeriesDescription = %s\n",
	$mpr->{'ID'}, "'".$mpr->{'type'}."'", "'".$mpr->{'xnat:quality'}."'",
	  $mpr->{'xnat:parameters'}->{'xnat:tr'}/1000, "'".$mpr->{'xnat:series_description'}."'";
      foreach my $scan (@bolds) {
	printf " - BOLD:   Scan # %2d, Type = %-10s, Quality = %-10s, TR = %6.2f, SeriesDescription = %s\n",
	  $scan->{'ID'}, "'".$scan->{'type'}."'", "'".$scan->{'xnat:quality'}."'",
	    $scan->{'xnat:parameters'}->{'xnat:tr'}/1000, "'".$scan->{'xnat:series_description'}."'";
      }
    }
    ($mpr,@bolds);
  } else {
    undef;
  }
}

=item $xconn->getFCScans(id=>$session_id)

Downloads scans for a session which match xnat:series_description='T1_MEMPRAGE RMS' or xnat:series_description='fMRI_resting_state'.

=cut

sub getFCScans {
  if($main::verbose > 4) { my ($pack,$file,$line,$sub) = caller; cluck "DEBUG: ${pack}::${sub}() called "; }
  my ($self,$params) = @_;
  # Do some sanity checking
  $self->_check_for_id($params);
  confess "ERROR: Cannot call \$xconn->getFCScans() with a 'scans' parameter." if $params->{scans};
  my ($mpr,@bolds,@scan_ids,@bold_ids) = $self->getFCScanList($params);
  return undef unless $mpr;
  foreach($mpr,@bolds) { push @scan_ids, $_->{'ID'}; }
  $params->{scans} = join(',',@scan_ids);
  my $tr = 0;
  foreach my $bold (@bolds) {
    push @bold_ids, $bold->{'ID'};
    my $new_tr = $bold->{'xnat:parameters'}->{'xnat:tr'};
    confess "ERROR: Found two TR values '$tr' and '$new_tr' for the BOLD functional runs for session '$params->{id}', cannot automatically process it!\n"
      if($tr && $new_tr != $tr);
    $tr = $new_tr;
  }
  $self->getSession($params);
  chomp(my $latfast = `which latfast`);
  my @latfast_command = ($latfast,'-id',$params->{id},'-mpr',$mpr->{ID},'-bold',join(',',@bold_ids),'-tr',sprintf('%.2f',($tr/1000)));
  if($latfast) {
      print "RUNNING: '@latfast_command'\n" if $main::verbose > 0;
      my $rv = system(@latfast_command);
      if( $rv ) {
	  warn "ERROR: Failed to run '@latfast_command'!\nREASON: $!\n";
	  return undef;
      } else {
	  print "Successfully ran '@latfast_command'!\n" if $main::verbose > 1;
	  return 1;
      }
  } else {
      print "RUN: '@latfast_command'.\n";
      return undef;
  }
}

sub prettySize {
  if($main::verbose > 4) { my ($pack,$file,$line,$sub) = caller; cluck "DEBUG: ${pack}::${sub}() called "; }
  my $size = shift;
  if($size > 1_073_741_824_000) {
     $size = sprintf('%0.2f',($size/1_099_511_627_776))." TB";
   } elsif($size > 1_048_576_000) {
     $size = sprintf('%0.2f',($size/1_073_741_824))." GB";
   } elsif($size > 1_024_000) {
     $size = sprintf('%0.2f',($size/1_048_576))." MB";
   } elsif($size > 1_000) {
     $size = sprintf('%0.2f',($size/1_024))." KB";
   } else {
     $size = ($size)." bytes";
   }
  $size;
}

sub prettyRate {
  if($main::verbose > 4) { my ($pack,$file,$line,$sub) = caller; cluck "DEBUG: ${pack}::${sub}() called "; }
  my $rate = shift;
  if($rate > 1_073_741_824_000) {
     $rate = sprintf('%0.2f',($rate/1_099_511_627_776))." TB/sec";
   } elsif($rate > 1_048_576_000) {
     $rate = sprintf('%0.2f',($rate/1_073_741_824))." GB/sec";
   } elsif($rate > 1_024_000) {
     $rate = sprintf('%0.2f',($rate/1_048_576))." MB/sec";
   } elsif($rate > 1_000) {
     $rate = sprintf('%0.2f',($rate/1_024))." KB/sec";
   } else {
     $rate = ($rate)." bytes/sec";
   }
  $rate;
}

sub _check_for_id {
  my ($self,$params) = @_;
  confess "ERROR: Must call with a reference to a parameter hash." unless (ref $params eq 'HASH');
  confess "ERROR: Must call with an 'id' parameter." unless $params->{id};
}
sub _check_for_params {
  my ($self,$params) = @_;
  confess "ERROR: Must call with a reference to a parameter hash." unless %{$params};
}

1;
__END__

